home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 4b.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  68KB  |  2,225 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "4.h"
  10. #include "dbxp.h"
  11. #include "setp.h"
  12. #include "arithp.h"
  13. #include "nodesp.h"
  14. #include "errmsgp.h"
  15. #include "evalp.h"
  16. #include "miscp.h"
  17. #include "smiscp.h"
  18. #include "chapp.h"
  19.  
  20. static int exist_compatible_type(Set, Symbol);
  21. static int compatible_op(Symbol, Node, Symbol);
  22. static Tuple valid_op_types(Symbol, Node);
  23. static int in_unary_ops(Symbol);
  24. static int op_suffix(Symbol);
  25. static Symbol op_suffix_gen(Symbol, int);
  26. static int in_numeric_types(Symbol);
  27. static int eq_universal_types(Symbol, Symbol);
  28. static int in_mult_types(Symbol, Symbol);
  29. static int in_mixed_mult_types(Symbol, Symbol);
  30. static int in_mod_types(Symbol, Symbol);
  31. static int in_adding_types(Symbol, Symbol);
  32. static int in_expon_types(Symbol, Symbol);
  33. static Symbol valid_arg_list(Symbol, Node);
  34. static Const check_constant_overflow(Const);
  35. static void literal_expression(Node);
  36. static Tuple order_arg_list(Node, Tuple);
  37. static void bind_arg(Node, Symbol, int, int);
  38. static int in_comparison_ops(Symbol);
  39. static Set find_compatible_type(Set, Set);
  40. static Tuple valid_concatenation_type(Set, Set);
  41.  
  42. /* we need the following constants in order to make some tests :
  43.  * does a constant belong to its type interval ?
  44.  */
  45.  
  46. extern int    ADA_MIN_INTEGER;
  47. extern int    ADA_MAX_INTEGER;
  48. extern int    *ADA_MAX_INTEGER_MP;
  49. extern int    *ADA_MIN_INTEGER_MP;
  50. extern long    ADA_MIN_FIXED, ADA_MAX_FIXED;
  51. extern int    *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
  52.  
  53. void result_types(Node expn)                              /*;result_types*/
  54. {
  55.     /* This procedure performs the first pass of type resolution on over-
  56.      * loadable  constructs :  operators,  subprograms and literals.
  57.      */
  58.  
  59.     Fortup    ft1;
  60.     Forset    fs1, fs2;
  61.     Node    op_node;
  62.     Node prefix_node;
  63.     Node    arg_list_node;
  64.     Tuple    tmp;
  65.     Set types;
  66.     Set ops;
  67.     Symbol    opn;
  68.     Set opns;
  69.     Set valid;
  70.     Symbol    sct;
  71.     Symbol    t;
  72.     Set usable, set1;
  73.     Symbol typ;
  74.     int    exists, nat;
  75.     Symbol    package;
  76.     Node    arg;
  77.  
  78.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC :  result_types");
  79.  
  80.     /* Check for previous type error.*/
  81.  
  82.     if (noop_error ) {
  83.         N_PTYPES(expn) = set_new(0);
  84.         return;
  85.     }
  86.  
  87.     op_node = N_AST1(expn);
  88.     arg_list_node = N_AST2(expn);
  89.     ops = set_new(0);
  90.     types = set_new(0);
  91.     /* The C code differs from SETL code in that set loop only needed for simple
  92.      * names        ds 8-jan-85
  93.      * this is not longer the case!! gs apr 1 85
  94.      */
  95.     set1 = N_NAMES(op_node);
  96.     FORSET(opn =(Symbol), set1, fs1);
  97.         nat = NATURE(opn);
  98.         if (nat == na_un_op || nat == na_op) {
  99.             tmp = valid_op_types(opn, expn);
  100.             opns = (Set) tmp[1];
  101.             valid = (Set) tmp[2];
  102.             if (set_size(valid) == 0)
  103.                 opns = set_new(0);
  104.             /* A predefined operator is usable if its resulting types appears
  105.              * in a lexically open scope, or a used package.
  106.              */
  107.             usable = set_new(0);
  108.             if (N_KIND(op_node) == as_selector 
  109.               && SCOPE_OF(opn) == symbol_standard0) {
  110.                 /* use of P.'op' for a predefined operator.  Name resolution
  111.                    * has already verified that the operator is defined in scope
  112.                    * P, or that the scope declares an implicit operator. (see
  113.                    * find_selected_comp and has_implicit_operator).
  114.                  */
  115.                 prefix_node = N_AST1(op_node);
  116.                 package = N_UNQ(prefix_node);
  117.                 /* after which it can be treated as a simple name.*/
  118.                 N_KIND(op_node) = as_simple_name;
  119.                 FORSET(t=(Symbol), valid, fs2);
  120.                     usable = set_with(usable, (char *) t);
  121.                 ENDFORSET(fs2);
  122.             }
  123.             else {        /* normal infix usage of operator */
  124.                 FORSET(t=(Symbol), valid, fs2);
  125.                     sct = SCOPE_OF(t);
  126.                     if (tup_mem((char *)sct, open_scopes)
  127.                       || tup_mem((char *)sct, used_mods))
  128.                         usable = set_with(usable, (char *) t);
  129.                 ENDFORSET(fs2);
  130.             }
  131.             /* usable := {t in valid | (sct := SCOPE_OF(t)) in open_scopes
  132.              *     or sct in used_mods};
  133.              */
  134.             if (set_size(usable) == 0 && set_size(valid) == 1 
  135.               && set_size(N_NAMES(op_node)) == 1) {
  136.                 pass1_error("operator is not directly visible",
  137.                   "6.6, 8.3, 8.4", op_node);
  138.                 return;
  139.             }
  140.             else {
  141.                 ops = set_union(ops, opns );
  142.                 types = set_union(types, usable);
  143.             }
  144.         }
  145.         else if (nat == na_procedure || nat == na_procedure_spec
  146.           || nat == na_function || nat == na_function_spec
  147.           || nat == na_entry || nat == na_entry_family    ) {
  148.             typ = valid_arg_list(opn, arg_list_node);
  149.             if (typ != (Symbol)0 ) {
  150.                 types = set_with(types, (char *) typ);
  151.                 ops = set_with(ops, (char *) opn);
  152.             }
  153.         }
  154.         else if (nat == na_literal)  {
  155.             /* A literal may overload a function. The literal is valid only
  156.              * if the argument list is empty.
  157.              */
  158.             if (tup_size(N_LIST(arg_list_node)) == 0) {
  159.                 types = set_with(types, (char *) TYPE_OF(opn));
  160.                 ops = set_with(ops , (char *) opn);
  161.             }
  162.         }
  163.     ENDFORSET(fs1);
  164.  
  165.     exists = FALSE;
  166.     FORTUP(arg=(Node), N_LIST(arg_list_node), ft1);
  167.         if (set_mem((char *)symbol_universal_fixed, N_PTYPES(arg))) {
  168.             exists = TRUE;
  169.             break;
  170.         }
  171.     ENDFORTUP(ft1);
  172.     if (set_size(types) == 0 && exists ) {
  173.         errmsg("Missing explicit conversion from universal fixed value",
  174.           "3.5.9, 4.5.5", op_node);
  175.         noop_error = TRUE;
  176.     }
  177. #ifdef DEBUG
  178.     if (cdebug2 > 0) {
  179.         TO_ERRFILE("resulting types ");
  180.         /* use zpsymset     from sdbx.c to list set for debugging 
  181.          * This is temporary measure until new errmsg package installed
  182.          */
  183.         zppsetsym(types);
  184.     }
  185. #endif
  186.     N_NAMES(op_node) = ops;
  187.     N_OVERLOADED(op_node) = TRUE;
  188.     N_PTYPES(expn) = types;
  189. }
  190.  
  191. void disambiguate(Node expn, Symbol context_typ)          /*;disambiguate*/
  192. {
  193.     /* TBSL: check translation of this procedure CAREFULLY!! (ds 22 may)*/
  194.  
  195.     /* Called from    resolve2, when more than one operator  or  function is
  196.      * compatible  with the context type.  Apart from true    ambiguity, this
  197.      * can also happen if both a predefined and a user-defined operator are
  198.      * visible. This is because all predefined operators in the language have
  199.      * generic signatures (e.g. universal_integer rather than INTEGER) and as
  200.      *  result, a user-defined operator does not hide the corresponding
  201.      * operator(they do not have the same signature). The solution is to
  202.      * choose in favor of the user-defined op. if it is defined in the same
  203.      * package as the type, or in an open scope, and in favor of the
  204.      * defined one otherwise. For comparison  operators which yields the pre-
  205.      * defined  type BOOLEAN, the  above reasoning applies to the type of its
  206.      * formals and not to the boolean context.
  207.      *
  208.      * On the other hand, a predefined operator of (generic) type o_t may be
  209.      * compatible with arguments of type a_t and with the context c_t, while
  210.      * a_t is in fact not compatible with c_t.  To catch that case, we check
  211.      * valid_op_types again to verify that the result is compatible with the
  212.      * context.
  213.      *
  214.      * A final wrinkle : if the context is universal, as in a number declara-
  215.      * tion, then the predefined operator is used even if a user-defined one
  216.      * is in scope.
  217.      */
  218.  
  219.     Node    op_node;
  220.     Node    args_node;
  221.     Set valid_ops, ovalid_ops;
  222.     Symbol    nam;
  223.     Symbol    opn;
  224.     Forset    fs1;
  225.     int exists;
  226.     Symbol    sc, scc;
  227.     Tuple tup;
  228.     /*TBSL: there are a number of statements of the form
  229.      *    valid_ops = {x in valid_ops | c(x) }
  230.      * In C we translate this as
  231.      *    ovalid_ops = valid_ops;
  232.      *    valid_ops = set_new(0);
  233.      *    FORSET(x=, ovalid_ops, fs1);
  234.      *        if(c(x)) set_with(valid_ops, x)
  235.      *    ENDFORSET
  236.      * Perhaps later we can do this be removing elements from valid_ops.
  237.      * Also we will eventually want to free dead sets.
  238.      */
  239.  
  240.     op_node = N_AST1(expn);
  241.     args_node = N_AST2(expn);
  242.     valid_ops = N_NAMES(op_node);
  243.     if (cdebug2 > 2) {
  244.         TO_ERRFILE("AT PROC: disambiguate");
  245.         FORSET(nam =(Symbol) , valid_ops, fs1);
  246.             TO_ERRFILE("OVERLOADS ");
  247.         ENDFORSET(fs1); 
  248.     }
  249.     ovalid_ops = valid_ops;
  250.     valid_ops = set_new(0);
  251.     FORSET(opn=(Symbol), ovalid_ops, fs1);
  252.         if ( (NATURE(opn) != na_op)
  253.           || compatible_op(opn, args_node, context_typ))
  254.             valid_ops = set_with(valid_ops, (char *) opn);
  255.     ENDFORSET(fs1);
  256.     /* return statements have been inserted earlier to simplify the logic
  257.      * of the translation to c (ds 22 may 84) 
  258.      */
  259.     if (in_univ_types(context_typ)) {
  260.         ovalid_ops = valid_ops;
  261.         valid_ops = set_new(0);
  262.         FORSET(opn=(Symbol), ovalid_ops, fs1);
  263.         if (TYPE_OF(opn) == context_typ)
  264.             valid_ops = set_with(valid_ops, (char *) opn);
  265.         ENDFORSET(fs1);
  266.         N_NAMES(op_node) = valid_ops;
  267.         return;
  268.     }
  269.  
  270.     exists = FALSE;
  271.     FORSET(nam=(Symbol), valid_ops, fs1);
  272.         sc = SCOPE_OF(nam);
  273.         tup = SIGNATURE(nam);
  274.         if (tup!=(Tuple)0)        /* avoid dereference of null pointer */
  275.             scc = (Symbol) tup[1];
  276.         else
  277.             scc = (Symbol)0;
  278.         if  (NATURE(nam) != na_op && (sc == SCOPE_OF(context_typ)
  279.           || in_open_scopes(sc)
  280.           /* maybe a compar op. Check against scope of type of first formal.*/
  281.           || (TYPE_OF(nam) == symbol_boolean
  282.           && ( scc!=(Symbol)0 && sc == SCOPE_OF(TYPE_OF(scc)))) ) ) {
  283.             exists = TRUE;
  284.             break;
  285.         }
  286.     ENDFORSET(fs1);
  287.     if (exists) {
  288.         /* user-defined operator(s) hide derived operator.*/
  289.         ovalid_ops = valid_ops;
  290.         valid_ops = set_new(0);
  291.         FORSET(nam=(Symbol), ovalid_ops, fs1);
  292.             if (NATURE(nam) != na_op)
  293.             valid_ops = set_with(valid_ops, (char *) nam);
  294.         ENDFORSET(fs1);
  295.         N_NAMES(op_node) = valid_ops;
  296.         return;
  297.     }
  298.  
  299.     exists = FALSE;
  300.     FORSET(nam=(Symbol), valid_ops, fs1);
  301.         if (NATURE(nam) == na_op) {
  302.             exists = TRUE;
  303.             break;
  304.         }
  305.     ENDFORSET(fs1);
  306.     if (exists) {
  307.         /* It will have precedence over imported user-defined functions.*/
  308.         ovalid_ops = valid_ops;
  309.         valid_ops = set_new(0);
  310.         FORSET(nam=(Symbol), ovalid_ops, fs1);
  311.             if (NATURE(nam) == na_op)
  312.                 valid_ops = set_with(valid_ops, (char *) nam);
  313.         ENDFORSET(fs1);
  314.  
  315.         if (is_fixed_type(root_type(context_typ))) {
  316.             /* remove mixed floating operators, that yield universal*/
  317.             /* real, but are not compatible with a fixed type context*/
  318.             ovalid_ops = valid_ops;
  319.             valid_ops = set_new(0);
  320.             FORSET(nam=(Symbol), ovalid_ops, fs1);
  321.             if (TYPE_OF(nam) != symbol_universal_real)
  322.                 valid_ops = set_with(valid_ops, (char *) nam);
  323.             ENDFORSET(fs1);
  324.         }
  325.     }
  326.     N_NAMES(op_node) = valid_ops;
  327. }
  328.  
  329. static int exist_compatible_type(Set set1, Symbol context_type)
  330.                                                     /*exist_compatible_type*/
  331. {
  332.     /* retun true if it exists one type of set1 that id compatible 
  333.      * with context_type
  334.      */
  335.  
  336.     Forset fs1;
  337.     Symbol t;
  338.  
  339.     FORSET(t=(Symbol), set1, fs1);
  340.         if (compatible_types(t, context_type))
  341.             return TRUE;
  342.     ENDFORSET(fs1);
  343.     return FALSE;
  344. }
  345.  
  346. static int compatible_op(Symbol opn, Node args_node, Symbol context_typ)
  347.                                                             /*;compatible_op*/
  348. {
  349.     Tuple    arg_list;
  350.     Set types1, types2;
  351.     Symbol    t;
  352.     Forset    fs1;
  353.  
  354.     if (cdebug2 > 2) TO_ERRFILE("AT PROC compatible_op");
  355.     /* In most cases, binary operators are homogenenous: the type of their
  356.      * arguments is also  the type of the result. We get the types    of the
  357.      * arguments to perform this test:
  358.      */
  359.     arg_list = N_LIST(args_node);
  360.     if (tup_size(arg_list) == 0)
  361.         types1 = set_new(0);
  362.     else
  363.         types1 = N_PTYPES(((Node)arg_list[1]));
  364.  
  365.     if (tup_size(arg_list) == 2 ) types2 = N_PTYPES(((Node) arg_list[2]));
  366.  
  367.     /* For comparison operators, the types of the operands are known to be
  368.      * compatible and unrelated to the boolean result. 
  369.      */
  370.  
  371.     if (in_comparison_ops(opn)) return TRUE;
  372.     if (opn == symbol_mulifl || opn == symbol_mulifx) {
  373.         FORSET(t=(Symbol), types2, fs1);
  374.             /* For these ops, the second argument yields the result type.*/
  375.             if (compatible_types(t, context_typ))
  376.                 return TRUE;
  377.         ENDFORSET(fs1);
  378.         return FALSE;
  379.     }
  380.     if (opn == symbol_cat_ac )
  381.         return ((exist_compatible_type (types1, context_typ)
  382.           && exist_compatible_type (types2, component_type(context_typ))));
  383.     if (opn == symbol_cat_ca)
  384.         return ((exist_compatible_type (types2, context_typ)
  385.           && exist_compatible_type (types1, component_type(context_typ))));
  386.     if (opn == symbol_cat_cc)
  387.         return ((exist_compatible_type (types2, component_type(context_typ))
  388.           && exist_compatible_type (types1, component_type(context_typ))));
  389.     return (exist_compatible_type (types1, context_typ));
  390. }
  391.  
  392. void remove_conversions(Node expn)  /*;remove_conversions*/
  393. {
  394.     /* If after the previous procedure an expression is still ambiguous, this
  395.      * may be due to an implicit conversion of a universal quantity. This can
  396.      * only     happen in the    presence of user-defined operators.  We therefore
  397.      * attempt to  resolve the expression  again, after removing user-defined
  398.      * operators from the  tree, whose  arguments are universal quantities.
  399.      * A full disambiguation would require that we try to remove these selec-
  400.      * tively. Here we simply  remove all  of them, and give up if the result
  401.      * is still ambiguous.
  402.      */
  403.  
  404.     Node    args_node, arg, op_node, a_list_node, ts, a_expn;
  405.     Set arg_types, arg_op, tset;
  406.     Symbol    n, t;
  407.     int        exists, nk;
  408.     Fortup    ft1;
  409.     Forset    fs1;
  410.  
  411.     if (cdebug2 > 2) TO_ERRFILE("AT PROC: remove_conversions");
  412.  
  413.     nk = N_KIND(expn);
  414.     if (nk == as_call || nk == as_op || nk == as_un_op) {
  415.         args_node = N_AST2(expn);
  416.         FORTUP(arg =(Node), N_LIST(args_node), ft1);
  417.             arg_types = N_PTYPES(arg);
  418.             if (set_size( arg_types) < 2 );    /*$ unambiguous.*/
  419.             else if (N_KIND(arg) != as_aggregate ) {
  420.                 op_node = N_AST1(arg);
  421.                 a_list_node = N_AST2(arg);
  422.                 arg_op = N_NAMES(op_node);
  423.                 if (!N_OVERLOADED(op_node) );
  424.                 /* Incomplete: could be an indexing on an overloaded call!*/
  425.  
  426.                 else if (
  427.                   !in_op_designators(original_name((Symbol)set_arb(arg_op))))
  428.                     /* May be overloaded because some of its arguments are.*/
  429.                     remove_conversions(arg);
  430.                 else {
  431.                     exists = FALSE;
  432.                     FORTUP(ts=(Node), N_LIST(a_list_node), ft1);
  433.                         if (set_mem((char *) symbol_universal_integer,
  434.                           N_PTYPES(ts)) || set_mem(
  435.                           (char *)symbol_universal_real, N_PTYPES(ts))) {
  436.                             exists = TRUE;
  437.                             break;
  438.                         }
  439.                     ENDFORTUP(ft1);
  440.                     if (exists) {
  441.                         /* Some arg is universal. Resolve as predefined op */
  442.                         tset = set_new(0);
  443.                         FORSET(n=(Symbol), arg_op, fs1);
  444.                             if (NATURE(n) == na_op)
  445.                                 tset = set_with(tset, (char *) n);
  446.                         ENDFORSET(fs1);
  447.                         N_NAMES(op_node) = tset;
  448.                         result_types(arg);
  449.                     }
  450.                 }
  451.             }
  452.         ENDFORTUP(ft1);
  453.  
  454.         /* Use the pruned argument list to resolve again the expression.*/
  455.         result_types(expn);
  456.     }
  457.     else if (nk == as_all) {
  458.         a_expn = N_AST1(expn);
  459.         remove_conversions(a_expn);
  460.         tset = set_new(0);
  461.         FORSET(t=(Symbol), N_PTYPES(a_expn), fs1);
  462.             if (is_access(t))
  463.                 tset = set_with(tset, (char *) designated_type(t));
  464.         ENDFORSET(fs1);
  465.         N_PTYPES(expn) = tset;
  466.     }
  467.     else {            /* may be continued: indexing, selection. */
  468.         ;
  469.     }
  470. }
  471.  
  472. static Tuple valid_op_types(Symbol opn, Node expn)         /*;valid_op_types*/
  473. {
  474.     /* This procedure is invoked during the bottom-up pass of type
  475.      * resolution. It determines the possible result types of predefined
  476.      * operators, using the possible types of their arguments.
  477.      * All arithmetic operators have special rules that apply within literal
  478.      * expressions. They are all treated in routine valid_arith_ops.
  479.      * For other operators, the following rule applies:
  480.      * Binary operators yield the intersection of the types of their two
  481.      * arguments, provided that they are boolean (For boolean operators),
  482.      * discrete (for ordering operators) , etc.
  483.      * The concatenation operator provides an exception : it will
  484.      * concatenate and array with an object of the component type, either
  485.      * on the left or right.
  486.      * The node can be a call ( "+"(a,b) for example) or a qualified name,
  487.      * in which case the only way to distinguish between unary and binary 
  488.      * ops. is to look at the  length of the argument list.
  489.      */
  490.  
  491.     /* const unary_ops  = ['+', '-', 'abs', 'not']; */
  492.     Node    op_node, arg_list_node, arg1, arg2;
  493.     Set possible_types, opossible_types, typ1, typ2;
  494.     Symbol    t2, t, typ;
  495.     Set        types;
  496.     Tuple    arg_list, tup;
  497.     Forset    fs1, fs2;
  498.     int        exists;
  499.  
  500.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_op_types");
  501.  
  502.     op_node = N_AST1(expn);
  503.     arg_list_node = N_AST2(expn);
  504.  
  505.     if (N_KIND(expn) == as_un_op
  506.       || (tup_size(N_LIST(arg_list_node)) == 1 && in_unary_ops(opn ) ) )
  507.         arg_list = order_arg_list(arg_list_node, unary_sig);
  508.     else
  509.         arg_list = order_arg_list(arg_list_node, binary_sig);
  510.     if (arg_list == (Tuple)0) {
  511.         tup = tup_new(2);
  512.         tup[1] = (char *) set_new(0);
  513.         tup[2] = (char *) set_new(0);
  514.         return tup;
  515.     }
  516.  
  517.     if (TYPE_OF(opn) == symbol_numeric)
  518.         return valid_arith_types(opn, arg_list);
  519.  
  520.     if (tup_size(arg_list) == 1) {
  521.         arg1 = (Node) arg_list[1];
  522.         possible_types =set_new(0);
  523.         FORSET(t=(Symbol), N_PTYPES(arg1), fs1);
  524.             possible_types = set_with(possible_types, (char *) base_type(t));
  525.         ENDFORSET(fs1);
  526.     }
  527.     else {
  528.         /*Binary operator.*/
  529.         arg1 = (Node) arg_list[1];
  530.         arg2 = (Node) arg_list[2];
  531.         typ1 = N_PTYPES(arg1);
  532.         typ2 = N_PTYPES(arg2);
  533.  
  534.         if (opn == symbol_cat)
  535.             /* Both arguments must have the same one-dimensional array type,
  536.              * or one or both may have the component type of such an array type
  537.              */
  538.             return (valid_concatenation_type ( typ1, typ2));
  539.  
  540.         else{
  541.             /* All other binary operators are homogeneous : the arguments
  542.              * must have compatible types,
  543.              */
  544.             possible_types = set_new(0);
  545.             FORSET(t=(Symbol), typ1, fs1);
  546.                 exists = FALSE;
  547.                 FORSET(t2=(Symbol), typ2, fs2);
  548.                     if (compatible_types(t, t2) && t != symbol_universal_fixed){
  549.                         exists = TRUE;
  550.                         break;
  551.                     }
  552.                 ENDFORSET(fs2);
  553.                 if (exists)
  554.                     possible_types = set_with(possible_types,
  555.                       (char *) base_type(t));
  556.             ENDFORSET(fs1);
  557.         }
  558.     }
  559.     /* Remove array types with incomplete private components.*/
  560.     opossible_types = possible_types;
  561.     possible_types = set_new(0);
  562.     FORSET(t=(Symbol), opossible_types, fs1);
  563.         /* the aim of this test is to remove array types with incomplete
  564.          * private components. We think taht the use of the function
  565.          * "is_fully_private" is indadequate in this case. The new test checks
  566.          * id the array is incomplete and private
  567.          */
  568.         /* if(!is_array(t) || ! is_fully_private(t) ) {*/
  569.         if (!is_array(t)
  570.           || (! ((((int) misc_type_attributes (t)) & TA_INCOMPLETE)
  571.           && (((int) misc_type_attributes (t))
  572.           & (TA_PRIVATE | TA_LIMITED_PRIVATE)))))
  573.             possible_types = set_with(possible_types, (char *) t);
  574.     ENDFORSET(fs1);
  575.  
  576.     typ = TYPE_OF(opn);
  577.     if (typ == symbol_boolean) {
  578.         /* equality and membership operators.*/
  579.  
  580.         if (opn == symbol_eq || opn == symbol_ne) {
  581.             exists = FALSE;
  582.             FORSET(t=(Symbol), possible_types, fs1);
  583.                 if (! is_limited_type(t)) {
  584.                     types = set_new1((char *) symbol_boolean);
  585.                     exists = TRUE;
  586.                     break;
  587.                 }
  588.             ENDFORSET(fs1);
  589.             if (! exists) types = set_new(0);
  590.         }
  591.         else {
  592.             if (set_size(possible_types) > 0)
  593.                 types = set_new1((char *) symbol_boolean);
  594.             else
  595.                 types = set_new(0);
  596.         }
  597.     }
  598.     else if(typ == symbol_boolean_type) {
  599.         /* Boolean and short circuit operators.*/
  600.  
  601.         if (opn == symbol_andthen || opn == symbol_orelse) {
  602.             types = set_new(0);
  603.             FORSET(t=(Symbol), possible_types, fs1);
  604.                 if (root_type(t) == symbol_boolean)
  605.                     types = set_with(types, (char *) t);
  606.             ENDFORSET(fs1);
  607.         }
  608.         else {
  609.             types = set_new(0);
  610.             FORSET(t=(Symbol), possible_types, fs1);
  611.                 if(root_type(t) == symbol_boolean || is_array(t)
  612.                   && no_dimensions(t) == 1
  613.                   && root_type((Symbol)(component_type(t))) == symbol_boolean)
  614.                     types = set_with(types, (char *) t);
  615.             ENDFORSET(fs1);
  616.         }
  617.     }
  618.     else if (typ == symbol_order_type) { /* Comparison operators.*/
  619.         exists = FALSE;
  620.         FORSET(t=(Symbol), possible_types, fs1);
  621.             if (is_scalar_type(t) || is_array(t) && no_dimensions(t) == 1
  622.               && is_discrete_type((Symbol)component_type(t))) {
  623.                 types = set_new1((char *) symbol_boolean);
  624.                 exists = TRUE;
  625.                 break;
  626.             }
  627.         ENDFORSET(fs1);
  628.         if (!exists) types = set_new(0);
  629.     }
  630.     else if (typ == symbol_any)           /* Syntax error*/
  631.         types = set_new1((char *) symbol_any);
  632.  
  633.     else {
  634.         /* The SETL simply prints the TYPE_OF field, i.e. the unique name
  635.          * of some entry in the symbol table. In C, this is not enough!
  636.          */
  637.         char *msg = emalloct(100, "valid-op-types-msg");
  638.  
  639.         sprintf(msg, "at loc: %d, nature: %s, value: %s",
  640.           typ, nature_str(NATURE(typ)), ORIG_NAME(typ) );
  641.         errmsg_str("system error: strange op type %", msg, "none", arg1);
  642.         efreet(msg, "valid-op-types-msg");
  643.     }
  644.     tup = tup_new(2);
  645.     tup[1] = (char *) set_new1((char *) opn);
  646.     tup[2] = (char *) types;
  647.     return tup;
  648. }
  649.  
  650. static int in_unary_ops(Symbol opn)                        /*;in_unary_ops*/
  651. {
  652.     /* const unary_ops  = ['+', '-', 'abs', 'not'];
  653.      * corresponds to opn in unary_ops
  654.      */
  655.     return (opn == symbol_add || opn == symbol_sub || opn == symbol_abs
  656.         || opn == symbol_not);
  657. }
  658. /* OP_SUFFIX codes used to represent SETL sfx character string values */
  659.  
  660. #define OP_SUFFIX_NONE    0
  661. #define OP_SUFFIX_I        1
  662. #define OP_SUFFIX_FL    2
  663. #define OP_SUFFIX_FX    3
  664. #define OP_SUFFIX_FLI    4
  665. #define OP_SUFFIX_FXI    5
  666. #define OP_SUFFIX_IFL    6
  667. #define OP_SUFFIX_IFX    7
  668. #define OP_SUFFIX_U        8
  669. #define OP_SUFFIX_UI    9
  670. #define OP_SUFFIX_UFL    10
  671. #define OP_SUFFIX_UFX    11
  672.  
  673. Tuple valid_arith_types(Symbol opn, Tuple arg_list)    /*;valid_arith_types*/
  674. {
  675.     /* Bottom-up pass over arithmetic expressions. return the pair:
  676.      * [possible operators, possible result types] .
  677.      */
  678. #ifdef TBSN
  679.  
  680.     macro i;  
  681.     "INTEGER"           endm;
  682.     macro fl;  
  683.     "FLOAT"           endm;
  684.     macro fx;  
  685.     "$FIXED"           endm;
  686.     macro ui; 
  687.     "universal_integer" endm;
  688.     macro ur; 
  689.     "universal_real"    endm;
  690.     macro ufx; 
  691.     "universal_fixed"   endm;
  692.  
  693.     const numeric_types = {
  694.         i, fl, fx, ui, ur}, 
  695.             universal_types = {
  696.             ui, ur}, 
  697.  
  698.                 adding_types = { 
  699.                 [i , i ], [fl, fl], [fx, fx], [ui, i],
  700.                     [ui, ui], [ur, ur], [ur, fx], [ur, fl]}, 
  701.  
  702.                     mult_types      = { 
  703.                     [i , i ], [fl, fl], [fx, fx], [ui, i ],
  704.                         [ui, ui], [ur, ur], [ur, fl]}, 
  705.  
  706.                         mixed_mult_types = { 
  707.                         [fx, i], [fx, ui], [ur, ui], [ur, i]}, 
  708.  
  709.                             mod_types      = { 
  710.                             [i, i], [ui, i], [i, ui], [ui, ui]}, 
  711.  
  712.                                 expon_types    = { 
  713.                                 [i , i ], [fl, i ], [ur, i ], [ui, i ],
  714.                                     [i , ui], [fl, ui], [ur, ui], [ui, ui]  }, 
  715.  
  716.  
  717.                                     op_suffix      = { 
  718.     [i, "i"], [ui, "i"], [fl, "fl"], [ur, "fl"],
  719.         [fx, "fx"] , [ufx, "fx"]
  720.                                 };
  721. #endif
  722.  
  723.     Set possible_types, types, ops, typ1, typ2;
  724.     Symbol    t;
  725.     Symbol    t1, t2, r_type, bt1, bt2;
  726.     int        sfx;
  727.     Forset    fs1, fs2;
  728.     Tuple    tup;
  729.  
  730.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_arith_types");
  731.     if  (tup_size(arg_list) == 1) {        /* Unary ops return the type*/
  732.         /* of their argument.*/
  733.         possible_types = (Set) (N_PTYPES((Node)(arg_list[1])) );
  734.  
  735.         types = set_new(0);
  736.         FORSET(t=(Symbol), possible_types, fs1);
  737.             if (in_numeric_types(root_type(t)))
  738.                 types = set_with(types, (char *) base_type(t));
  739.         ENDFORSET(fs1);
  740.  
  741.         /*Construct the unary version of the operator name.*/
  742.         if (opn == symbol_add) opn = symbol_addu;
  743.         else if (opn == symbol_sub) opn = symbol_subu;
  744.         /*ops = ??{ opn + op_suffix(root_type(t)): t in types};*/
  745.         ops = set_new(0);
  746.         FORSET(t=(Symbol), types, fs1);
  747.             ops = set_with(ops,
  748.               (char *)op_suffix_gen(opn, op_suffix(root_type(t))));
  749.         ENDFORSET(fs1);
  750.         tup = tup_new(2);
  751.         tup[1] = (char *) ops;
  752.         tup[2] = (char *) types;
  753.         return tup;
  754.     }
  755.     else {
  756.         typ1 = N_PTYPES((Node)(arg_list[1]));
  757.         typ2 = N_PTYPES((Node)(arg_list[2]));
  758.  
  759.         ops = set_new(0);
  760.         types =set_new(0);
  761.  
  762.         FORSET(t1=(Symbol), typ1, fs1);
  763.             FORSET(t2=(Symbol), typ2, fs2);
  764.                 sfx =OP_SUFFIX_NONE;/* Suffix to designate type of op.*/
  765.                 r_type = (Symbol)0;        /*will indicate type found.*/
  766.                 bt1 = root_type(t1);
  767.                 bt2 = root_type(t2);
  768.  
  769.                 if (opn == symbol_add || opn == symbol_sub) {
  770.                     if (in_adding_types(bt1, bt2)
  771.                       || in_adding_types(bt2, bt1) )
  772.                         r_type = intersect_types(t1, t2);
  773.                 }
  774.                 else if (opn == symbol_mul || opn == symbol_div) {
  775.                     if (in_mult_types(bt1, bt2) || in_mult_types(bt2, bt1) ) {
  776.                         if (is_fixed_type(bt1)||is_fixed_type(bt2))
  777.                             r_type = symbol_universal_fixed;
  778.                         else
  779.                             r_type = intersect_types(t1, t2);
  780.                     }
  781.                     else {
  782.                         /* Mixed mode operation on fixed types, or
  783.                          * literal expression.
  784.                          */
  785.                         if (in_mixed_mult_types(bt1, bt2) ) {
  786.                             if (eq_universal_types(bt1, bt2 )) {
  787.                                 /* Literal expr.*/
  788.                                 r_type = symbol_universal_real;
  789.                                 sfx = OP_SUFFIX_FLI;    /* Compile-time op.*/
  790.                             }
  791.                             else if (base_type(t2) == symbol_integer) {
  792.                                 /* Mixed mode operation with a fixed type.
  793.                                  * If the first argument is universal, the
  794.                                  * result is $FIXED, i.e any fixed type.
  795.                                  */
  796.                                 if (t1 == symbol_universal_real )
  797.                                     r_type = symbol_dfixed;
  798.                                 else r_type = t1;
  799.                                 sfx = OP_SUFFIX_FXI;    /* Run-time operation.*/
  800.                             }
  801.                             else if (bt2 == symbol_universal_integer) {
  802.                                 /* specific type on left*/
  803.                                 r_type = t1;
  804.                                 sfx = OP_SUFFIX_FXI;
  805.                             }
  806.                         }
  807.                         else if (in_mixed_mult_types(bt2, bt1)
  808.                           && opn == symbol_mul/* '*'*/) {
  809.                             /* Mixed modes are not commutative for division.*/
  810.                             if (eq_universal_types(bt1, bt2) ) {
  811.                                 r_type = symbol_universal_real;
  812.                                 sfx = OP_SUFFIX_IFL;
  813.                             }
  814.                             else if (base_type(t1) == symbol_integer) {
  815.                                 /* $FIXED, or the specific fixed type t2.*/
  816.                                 if (t2 == symbol_universal_real)
  817.                                     r_type = symbol_dfixed;
  818.                                 else r_type = t2;
  819.                                 sfx = OP_SUFFIX_IFX;
  820.                             }
  821.                             else if (bt1 == symbol_universal_integer) {
  822.                                 /* specific type on right*/
  823.                                 r_type = t2;
  824.                                 sfx = OP_SUFFIX_IFX;
  825.                             }
  826.                         }
  827.                     }
  828.                 }
  829.                 else if (opn == symbol_mod || opn == symbol_rem) {
  830.                     if (in_mod_types(bt1, bt2) )
  831.                         r_type = intersect_types(t1, t2);
  832.                 }
  833.                 else if(opn == symbol_exp) {
  834.                     /* The result of an exponentiation has the type of the
  835.                      * first argument.
  836.                      */
  837.                     if (in_expon_types(bt1, bt2)) r_type = t1;
  838.                 }
  839.  
  840.                 if (r_type != (Symbol)0) {    /* Pair of matching types found.*/
  841.                     /* The result type of an arithmetic operation does not carry
  842.                      * the constraint (if any) of the arguments. Therefore, drop
  843.                      * the constraint on the result if it appears as a subtype.
  844.                       */
  845.                     types = set_with(types, (char *)  base_type(r_type));
  846.  
  847.                     /* Append to the operator name a suffix that specifies the
  848.                      * type of its arguments and the type returned.
  849.                       */
  850.                     if (sfx == OP_SUFFIX_NONE)
  851.                         sfx = op_suffix(root_type(r_type));
  852.                     ops = set_with(ops, (char *) op_suffix_gen(opn , sfx) );
  853.                 }
  854.             ENDFORSET(fs2);
  855.         ENDFORSET(fs1);
  856.     }
  857.     tup = tup_new(2);
  858.     tup[1] = (char *)ops;
  859.     tup[2] = (char *)types;
  860.     return tup;
  861. }
  862.  
  863. static int op_suffix(Symbol ocode)                              /*;op_suffix*/
  864. {
  865.     /*    Return C analog of op_suffix in SETL version.
  866.      * op_suffix      = { [i, 'i'], [ui, 'i'], [fl, 'fl'], [ur, 'fl'],
  867.      *         [fx, 'fx'] , [ufx, 'fx']};
  868.      */
  869.     if (ocode == symbol_integer) return OP_SUFFIX_I;
  870.     if (ocode == symbol_universal_integer) return OP_SUFFIX_I;
  871.     if (ocode == symbol_float) return OP_SUFFIX_FL;
  872.     if (ocode == symbol_universal_real)    return OP_SUFFIX_FL;
  873.     if (is_fixed_type(ocode)) return OP_SUFFIX_FX;
  874.     if (ocode == symbol_universal_fixed) return OP_SUFFIX_FX;
  875.     return OP_SUFFIX_NONE;
  876. }
  877.  
  878. static Symbol op_suffix_gen(Symbol op, int sfx)                 /*;op_suffix_gen*/
  879. {
  880.     /* Generate symbol correspond to op with suffix code sfx */
  881.     if (sfx == OP_SUFFIX_NONE) return op;
  882.     if (op == symbol_abs) {
  883.         if (sfx == OP_SUFFIX_FL) return symbol_absfl;
  884.         if (sfx == OP_SUFFIX_FX) return symbol_absfx;
  885.         if (sfx == OP_SUFFIX_I) return symbol_absi;
  886.     }
  887.     else if (op == symbol_add) { /* + */
  888.         if (sfx == OP_SUFFIX_FL)        return symbol_addfl;    /* +fl */
  889.         if (sfx == OP_SUFFIX_FX)        return symbol_addfx;    /* +fx */
  890.         if (sfx == OP_SUFFIX_I)        return symbol_addi;    /* +i  */
  891.         if (sfx == OP_SUFFIX_U)        return symbol_addu;    /* +u  */
  892.         if (sfx == OP_SUFFIX_UFL)        return symbol_addufl;    /* +ufl */
  893.         if (sfx == OP_SUFFIX_UFX)        return symbol_addufx;    /* +ufx */
  894.         if (sfx == OP_SUFFIX_UI)        return symbol_addui;    /* +ui */
  895.     }
  896.     else if (op == symbol_addu) { /* +u */
  897.         if (sfx == OP_SUFFIX_FL)        return symbol_addufl;    /* +ufl */
  898.         if (sfx == OP_SUFFIX_FX)        return symbol_addufx;    /* +ufx */
  899.         if (sfx == OP_SUFFIX_I)        return symbol_addui;    /* +ui */
  900.     }
  901.     else if (op == symbol_div) {    /* / */
  902.         if (sfx == OP_SUFFIX_FL)        return symbol_divfl;    /* /fl */
  903.         if (sfx == OP_SUFFIX_FLI)        return symbol_divfli;    /* /fli */
  904.         if (sfx == OP_SUFFIX_FX)        return symbol_divfx;    /* /fx */
  905.         if (sfx == OP_SUFFIX_FXI)        return symbol_divfxi;    /* /fxi */
  906.         if (sfx == OP_SUFFIX_I)        return symbol_divi;    /* /i */
  907.     }
  908.     else if (op == symbol_exp) {
  909.         if (sfx == OP_SUFFIX_I)        return symbol_expi;    /* **i */
  910.         if (sfx == OP_SUFFIX_FL)        return symbol_expfl;    /* **fl */
  911.     }
  912.     else if (op == symbol_mod) {    /* mod */
  913.         if (sfx == OP_SUFFIX_I)        return symbol_modi;    /* modi */
  914.     }
  915.     else if (op == symbol_mul) {    /* * */
  916.         if (sfx == OP_SUFFIX_I)        return symbol_muli;    /* *i  */
  917.         if (sfx == OP_SUFFIX_FL)        return symbol_mulfl;    /* *fl */
  918.         if (sfx == OP_SUFFIX_FLI)        return symbol_mulfli;    /* *fli */
  919.         if (sfx == OP_SUFFIX_FX)        return symbol_mulfx;    /* *fx */
  920.         if (sfx == OP_SUFFIX_FXI)        return symbol_mulfxi;    /* *fxi */
  921.         if (sfx == OP_SUFFIX_IFL)        return symbol_mulifl;    /* *ifl */
  922.         if (sfx == OP_SUFFIX_IFX)        return symbol_mulifx;    /* *ifx */
  923.     }
  924.     else if (op == symbol_rem) {
  925.         if (sfx == OP_SUFFIX_I)        return symbol_remi;    /* remi */
  926.     }
  927.     else if (op == symbol_sub) {        /* - */
  928.         if (sfx == OP_SUFFIX_FL)        return symbol_subfl;    /* -fl */
  929.         if (sfx == OP_SUFFIX_FX)        return symbol_subfx;    /* -fx */
  930.         if (sfx == OP_SUFFIX_I)        return symbol_subi;    /* -i  */
  931.         if (sfx == OP_SUFFIX_U)        return symbol_subu;    /* -u  */
  932.         if (sfx == OP_SUFFIX_UFL)        return symbol_subufl;    /* -ufl */
  933.         if (sfx == OP_SUFFIX_UFX)        return symbol_subufx;    /* -ufx */
  934.         if (sfx == OP_SUFFIX_UI)        return symbol_subui;    /* -ui */
  935.     }
  936.     else if (op == symbol_subu) { /* -u */
  937.         if (sfx == OP_SUFFIX_I)        return symbol_subui;    /* -ui */
  938.         if (sfx == OP_SUFFIX_FL)        return symbol_subufl;    /* -ufl */
  939.         if (sfx == OP_SUFFIX_FX)        return symbol_subufx;    /* -ufx */
  940.     }
  941. #ifdef TBSL
  942.     -- need to handle subui and addui more completely, check
  943.         -- other unary operators
  944. #endif
  945. #ifdef DEBUG
  946.     printf("unable to match operator\n");
  947.     zpsym(op);
  948. #endif
  949.     chaos("op_suffix_gen(4)");
  950.     return (Symbol)0;
  951. }
  952.  
  953. #undef OP_SUFFIX_NONE 
  954. #undef OP_SUFFIX_I    
  955. #undef OP_SUFFIX_FL    
  956. #undef OP_SUFFIX_FX    
  957. #undef OP_SUFFIX_FLI    
  958. #undef OP_SUFFIX_FXI    
  959. #undef OP_SUFFIX_IFL    
  960. #undef OP_SUFFIX_IFX    
  961. #undef OP_SUFFIX_U    
  962. #undef OP_SUFFIX_UI    
  963. #undef    OP_SUFFIX_UFL    
  964. #undef OP_SUFFIX_UFX    
  965.  
  966. Symbol intersect_types(Symbol t1, Symbol t2) /*;intersect_types*/
  967. {
  968.     /* Find the more specific of two numeric types, if they are compatible.
  969.      * In particular, if  only one of them is  universal, return the other.
  970.      * Called to validate arithmetic arguments and bounds of subtypes.
  971.      */
  972.  
  973.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  intersect_types");
  974.  
  975. #ifdef TBSN    
  976.     Const universal_types =
  977.         { 'universal_integer', 'universal_real', '$FIXED' };
  978. #endif
  979.     if (compatible_types(t1, t2)) {
  980.         if (t1 == symbol_universal_integer || t1 == symbol_universal_real
  981.           || t1 == symbol_dfixed)
  982.             return (t2);
  983.         else if (t2 == symbol_universal_integer || t2 == symbol_universal_real
  984.           || t2 == symbol_dfixed)
  985.             return (t1);
  986.         else return(t1);
  987.     }
  988.     else return (Symbol)0;
  989. }
  990.  
  991. static int in_numeric_types(Symbol t)                  /*;in_numeric_types*/
  992. {
  993.     return t == symbol_integer
  994.       || t == symbol_float
  995.       || is_fixed_type(t)
  996.       || t == symbol_universal_integer
  997.       || t == symbol_universal_real;
  998. }
  999.  
  1000. static int eq_universal_types(Symbol t1, Symbol t2) /*;eq_universal_types*/
  1001. {
  1002.     return (t1 == symbol_universal_integer && t2 == symbol_universal_real)
  1003.       || (t2 == symbol_universal_integer && t1 == symbol_universal_real);
  1004. }
  1005.  
  1006. static int in_adding_types(Symbol t1, Symbol t2)         /*;in_adding_types*/
  1007. {
  1008.     /* [symbol_integer , symbol_integer ], 
  1009.      * [symbol_float, symbol_float], 
  1010.      * [symbol_dfixed, symbol_dfixed], 
  1011.      * [symbol_universal_real, symbol_universal_real], 
  1012.      * [symbol_universal_integer, symbol_integer],
  1013.      * [symbol_universal_integer, symbol_universal_integer], 
  1014.      * [symbol_universal_real, symbol_dfixed], 
  1015.      * [symbol_universal_real, symbol_float] ,
  1016.      */
  1017.     if (t1 == t2) {
  1018.         if (t1 == symbol_integer || t1 == symbol_float || is_fixed_type(t1)
  1019.           || t1 == symbol_universal_real) return TRUE;
  1020.     }
  1021.     if (t1 == symbol_universal_integer)
  1022.         return (t2 == symbol_integer|| t2 == symbol_universal_integer);
  1023.     if (t1 == symbol_universal_real)
  1024.         return (is_fixed_type(t2) || t2 == symbol_float);
  1025.     return FALSE;
  1026. }
  1027.  
  1028. static int in_mult_types(Symbol t1, Symbol t2)              /*;in_mult_types*/
  1029. {
  1030.     /* { [symbol_integer , symbol_integer ], 
  1031.      * [symbol_float, symbol_float], 
  1032.      * [symbol_dfixed, symbol_dfixed], 
  1033.      * [symbol_universal_integer, symbol_universal_integer], 
  1034.  
  1035.      * [symbol_universal_integer, symbol_integer ],
  1036.      * [symbol_universal_real, symbol_universal_real], 
  1037.      * [symbol_universal_real, symbol_float], 
  1038.      * }
  1039.       */
  1040.     if (t1 == t2)
  1041.         return (t1 == symbol_integer || t1 == symbol_float || is_fixed_type(t1)
  1042.           || t1 == symbol_universal_integer || t1 == symbol_universal_real);
  1043.     if (t1 == symbol_universal_integer && t2 == symbol_integer)
  1044.         return TRUE;
  1045.     if (t1 == symbol_universal_real)
  1046.         return (t2 == symbol_float);
  1047.     return FALSE;
  1048. }
  1049.  
  1050. static int in_mixed_mult_types(Symbol t1, Symbol t2)  /*;in_mixed_mult_types*/
  1051. {
  1052.     /* [symbol_dfixed, symbol_integer],
  1053.      * [symbol_dfixed, symbol_universal_integer], 
  1054.      * [symbol_universal_real, symbol_universal_integer], 
  1055.      * [symbol_universal_real, symbol_integer]
  1056.      */
  1057.     if (is_fixed_type(t1))
  1058.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1059.     if (t1 == symbol_universal_real)
  1060.         return (t2 == symbol_universal_integer || t2 == symbol_integer);
  1061.     return FALSE;
  1062. }
  1063.  
  1064. static int in_mod_types(Symbol t1, Symbol t2)              /*;in_mod_types*/
  1065. {
  1066.     /* [symbol_integer, symbol_integer], 
  1067.      * [symbol_integer, symbol_universal_integer], 
  1068.      * [symbol_universal_integer, symbol_integer], 
  1069.      * [symbol_universal_integer, symbol_universal_integer]
  1070.      */
  1071.  
  1072.     if (t1 == symbol_integer)
  1073.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1074.     if (t1 == symbol_universal_integer)
  1075.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1076.     return FALSE;
  1077. }
  1078.  
  1079. static int in_expon_types(Symbol t1, Symbol t2)             /*;in_expon_types*/
  1080. {
  1081.     /* [symbol_integer , symbol_universal_integer], 
  1082.      * [symbol_integer , symbol_integer ], 
  1083.      * [symbol_float, symbol_integer ], 
  1084.      * [symbol_float, symbol_universal_integer], 
  1085.      * [symbol_universal_integer, symbol_universal_integer] 
  1086.      * [symbol_universal_integer, symbol_integer ],
  1087.      * [symbol_universal_real, symbol_integer ],
  1088.      * [symbol_universal_real, symbol_universal_integer],
  1089.       */
  1090.     if (t1 == symbol_integer)
  1091.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1092.     if (t1 == symbol_float)
  1093.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1094.     if (t1 == symbol_universal_integer)
  1095.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1096.     if (t1 == symbol_universal_real)
  1097.         return (t2 == symbol_integer || t2 == symbol_universal_integer);
  1098.     return FALSE;
  1099. }
  1100.  
  1101. static Symbol valid_arg_list(Symbol proc_name, Node arg_list_node)
  1102.                                                             /*;valid_arg_list*/
  1103. {
  1104.     Tuple    formals, arg_list;
  1105.     Node    actual;
  1106.     Set        a_types;
  1107.     Symbol    t;
  1108.     Forset    fs1;
  1109.     Fortup    ft1;
  1110.     int        exists, i;
  1111.     Symbol    f;
  1112.  
  1113.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_arg_list");
  1114.     /* This procedure is called during the bottom-up phase of overloading
  1115.      * resolution. It checks whether an argument list is compatible with
  1116.      * the formals of a subprogram, and yields the return type of the
  1117.      * subprogram if the answer is affirmative.
  1118.       * The arguments have already been processed by the first pass.
  1119.      */
  1120.  
  1121.     formals = SIGNATURE(proc_name);
  1122.     arg_list = order_arg_list(arg_list_node, formals); /*Normalize arguments*/
  1123.  
  1124.     if (cdebug2 > 0)  TO_ERRFILE("valid arg list :  formals ");
  1125.  
  1126.     if (arg_list == (Tuple)0) return (Symbol)0;       /* no match, or error*/
  1127.  
  1128.     /* Traverse signature and actuals, and verify that types match.*/
  1129.  
  1130.     FORTUPI(f=(Symbol), formals, i, ft1);
  1131.         actual = (Node) arg_list[i];
  1132.         if (actual == OPT_NODE) continue;    /* Default value exists.*/
  1133.         else a_types = N_PTYPES(actual);
  1134.  
  1135.         exists = FALSE;
  1136.         FORSET(t=(Symbol), a_types, fs1);
  1137.             if (compatible_types(TYPE_OF(f), t)) {
  1138.                 exists = TRUE;
  1139.                 break;
  1140.             }
  1141.         ENDFORSET(fs1);
  1142.         if (exists) 
  1143.             continue;
  1144.         else
  1145.             return (Symbol)0;
  1146.     ENDFORTUP(ft1);
  1147.  
  1148.     /* All arguments have a match.*/
  1149.     return (TYPE_OF(proc_name));
  1150. }
  1151.  
  1152. void complete_op_expr(Node expn, Symbol ctx_type) /*;complete_op_expr*/
  1153. {
  1154.     /* Complete the top-down pass of an expression with a predefined
  1155.      * operator.
  1156.      * For predefined operators, the signature of the operator does not
  1157.      * fix the type of the arguments, because it only specifies a class
  1158.      * of types. The precise type to be used is either imposed by context
  1159.      * (this is the argument ctx_type) or is found by requiring consistency
  1160.      * between the possible types of the arguments themselves.
  1161.      */
  1162. #ifdef TBSN
  1163.     const comparison_ops = {
  1164.     '<', '<=', '>', '>=', '=', '/='
  1165.     };
  1166. #endif
  1167.  
  1168.     Node    o, args;
  1169.     Symbol    op_name;
  1170.     Tuple    arg_list;
  1171.     Node    arg1, arg2;
  1172.     Set        t_left, t_right, ok_types, univ;
  1173.     Symbol    ctx_root, t2, t1, isym, typ;
  1174.     Forset    fs1, fs2;
  1175.  
  1176.  
  1177.     o = N_AST1(expn);
  1178.     args = N_AST2(expn);
  1179.     op_name      = N_UNQ(o);
  1180.     arg_list  = N_LIST(args);
  1181.  
  1182.     if (cdebug2 > 0) TO_ERRFILE("complete_op_expr:");
  1183.  
  1184.     if (tup_size(arg_list) == 1)
  1185.         arg_list = order_arg_list(args, unary_sig);
  1186.     else
  1187.         arg_list = order_arg_list(args, binary_sig);
  1188.  
  1189.     if (arg_list == (Tuple)0) return;
  1190.     N_LIST(args) = arg_list;      /* Normalize if named parameters. */
  1191.  
  1192.     if (tup_size( arg_list) == 2) {        /*Binary operators.*/
  1193.         arg1 = (Node) arg_list[1];
  1194.         arg2 = (Node) arg_list[2];
  1195.         t_left = N_PTYPES(arg1);
  1196.         t_right = N_PTYPES(arg2);
  1197.  
  1198.         typ = TYPE_OF(op_name);
  1199.         if (typ == symbol_universal_integer || typ == symbol_universal_real
  1200.           || typ == symbol_universal_fixed
  1201.           || (typ!=(Symbol)0 && is_fixed_type(typ)))  {
  1202.             ctx_root = root_type(ctx_type);
  1203.  
  1204.             if (ctx_type == symbol_universal_fixed) {
  1205.                 /* Must have appeared in a conversion. Each argument must be of
  1206.                  * some fixed type. 
  1207.                  */
  1208.                 t1 = ctx_type;        /* by default */
  1209.                 FORSET(t1=(Symbol), t_left, fs1);
  1210.                     if (compatible_types(t1, symbol_dfixed)) break;
  1211.                 ENDFORSET(fs1);
  1212.  
  1213.                 t2 = ctx_type;
  1214.                 FORSET(t2=(Symbol), t_right, fs2);
  1215.                     if (compatible_types(t2, symbol_dfixed)) break;
  1216.                 ENDFORSET(fs1);
  1217.                 /* TBSL: not catching ambiguity in these loops.*/
  1218.                 resolve2(arg1, t1);
  1219.                 resolve2(arg2, t2);
  1220.             }
  1221.             else if (op_name == symbol_mulfxi || op_name == symbol_mulifx
  1222.               || op_name == symbol_divfxi || op_name == symbol_expi
  1223.               || op_name == symbol_expfl) {
  1224.                 /* For mixed mode fixed operations and  exponentiation,
  1225.                  * the  type  from  context  is imposed    on  the     first
  1226.                  * argument. The second one must be INTEGER.
  1227.                  */
  1228.                 if (op_name == symbol_mulifx) { /*permute arguments.*/
  1229.                     Tuple tup= tup_new(2);
  1230.                     tup[1] = (char *) arg2;
  1231.                     tup[2] = (char *) arg1;
  1232.                     N_LIST(args) = tup;
  1233.                     arg1 = (Node) tup[1];
  1234.                     arg2 = (Node) tup[2];
  1235.                     op_name = symbol_mulfxi;
  1236.                     N_UNQ(o) = symbol_mulfxi;
  1237.                 }
  1238.  
  1239.                 if (ctx_type == symbol_dfixed) {
  1240.                     /* mixed mode expression in a context that does not
  1241.                     * have an explicit fixed type: comparison or conversion.
  1242.                     */
  1243.                     errmsg("invalid context for mixed-mode operation",
  1244.                       "4.5.5, 4.10", expn);
  1245.                 }
  1246.                 if (op_name == symbol_expfl && is_fixed_type(ctx_root)) {
  1247.                     /* universal expression in fixed context: no ** .*/
  1248.                     errmsg(
  1249.                       "Missing explicit conversion from universal_real value ",
  1250.                          "4.5.6", expn);
  1251.                 }
  1252.                 resolve2(arg1, ctx_type);
  1253.                 resolve2(arg2, symbol_integer);
  1254.                 /*
  1255.                  * The second argument is not universal, yet the whole
  1256.                  * may be constant-foldable. Fold arg2, and if static
  1257.                  * make universal again.
  1258.                  */
  1259.                 eval_static(arg2);
  1260.                 if (N_KIND(arg2) == as_ivalue )
  1261.                     N_TYPE(arg2) = symbol_universal_integer;
  1262. #ifdef TBSL
  1263.                 /* TBSL (In C, will need explicit conversion)*/
  1264. #endif
  1265.             }
  1266.             else if (op_name == symbol_mulfli
  1267.               || op_name == symbol_mulifl
  1268.               || op_name == symbol_divfli) {
  1269.                 /* These mixed mode operations appear in number declara-
  1270.                  * tions, in which case they are universal, or in a fixed
  1271.                  * type context.
  1272.                  */
  1273.                 if (op_name == symbol_mulifl) { /* permute arguments.*/
  1274.                     Tuple tup = tup_new(2);
  1275.                     tup[1] = (char *) arg2;
  1276.                     tup[2] = (char *) arg1;
  1277.                     N_LIST(args) = tup;
  1278.                     arg1 = (Node) tup[1];
  1279.                     arg2 = (Node) tup[2];
  1280.                     op_name = symbol_mulfli;
  1281.                     N_UNQ(o) = symbol_mulfli;
  1282.                 }
  1283.                 if (ctx_root == symbol_universal_real)
  1284.                     t2 = symbol_universal_integer;
  1285.                 else if (is_fixed_type(ctx_root))
  1286.                     /* universal expression in fixed context.*/
  1287.                     t2 = symbol_integer;
  1288.                 else {
  1289.                     errmsg("Invalid context for mixed mode operation",
  1290.                       "4.5.5, 4.10", expn);
  1291.                     N_KIND(expn) = as_opt;
  1292.                     return;
  1293.                 }
  1294.                 resolve2(arg1, ctx_type);
  1295.                 resolve2(arg2, t2);
  1296.             }
  1297.             else {
  1298.                 /* For other  arithmetic operators, propagate  context
  1299.                   * type to arguments. 
  1300.                   */
  1301.                 resolve2(arg1, ctx_type);
  1302.                 resolve2(arg2, ctx_type);
  1303.             }
  1304.             /* If the context is universal, evaluate the corresponding
  1305.              * literal expression.
  1306.              */
  1307.             if (in_univ_types(ctx_type ) || (is_fixed_type(ctx_root)
  1308.               && N_KIND(arg1) == as_ivalue && N_KIND(arg2) == as_ivalue))
  1309.                 literal_expression(expn);
  1310.             if ((op_name == symbol_mulfl || op_name == symbol_divfl)
  1311.               && (is_fixed_type(ctx_root)) && (!is_fixed_type(ctx_type))) {
  1312.                 /* These floating point operation may appear in some fixed
  1313.                  * type context if their constituents are literals. this is
  1314.                  * an error because the operation yields a universal_fixed
  1315.                  * quantity that must be explicitly converted If a conversion
  1316.                  * is present, the context type itself is symbol_dfixed.
  1317.                  */
  1318.                 errmsg_l("Missing explicit conversion from ",
  1319.                   "universal_fixed value ", "4.5.5", expn);
  1320.             }
  1321.         }
  1322.         else if (typ == symbol_order_type ||  typ == symbol_discrete_type
  1323.           ||  typ == symbol_boolean) {
  1324.             /* Equality, set or comparison  operators. Verify that  there  is
  1325.              * only one possible type choice for both arguments. If both arg.
  1326.              * are universal, we must choose a universal interpretation for
  1327.              * each. Otherwise, the non-universal type is applied to both.
  1328.              */
  1329. #ifdef TBSN
  1330.             /* it happens to be wrong.*/
  1331.             /* In the case of an array compared to an aggregate, the array is
  1332.                  * already constrained as it is an object.
  1333.                  */
  1334.             need_constr_type = FALSE;
  1335.             exists = FALSE;
  1336.             if (N_KIND(arg1) == as_simple_name )  {
  1337.                 arg1_name = N_UNQ(arg1);
  1338.                 exists = TRUE;
  1339.             }
  1340. #endif
  1341.             ok_types = set_new(0);
  1342.             FORSET(t1=(Symbol), t_left, fs1);
  1343.                 FORSET(t2=(Symbol), t_right, fs2);
  1344.                     isym = intersect_types(t1, t2);
  1345.                     if (isym!=(Symbol)0)  {
  1346. #ifdef TBSN
  1347.                         if (N_KIND(arg1) == as_selector) {
  1348.                             obj = N_AST1(arg1);
  1349.                             s_node = N_AST2(arg1);
  1350.                             selector = N_VAL(s_node);
  1351.                             types1 = N_PTYPES(obj);
  1352.                             FORSET( o_t =(Symbol), types1, fs1);
  1353.                                 if (is_access(o_t) )
  1354.                                     t = (Symbol) designated_type(o_t);
  1355.                                 else 
  1356.                                     t = o_t;
  1357.                                 if (is_record(t))
  1358.                                     decls = (Declaredmap)
  1359.                                       declared_components(base_type(t));
  1360.                                 else if (is_task_type(t))
  1361.                                     decls = DECLARED(t);
  1362.                                 arg1_name = dcl_get(decls, selector);
  1363.                                 if(arg1_name != (Symbol)0
  1364.                                   && compatible_types(TYPE_OF(arg1_name),isym)){
  1365.                                     exists = TRUE;
  1366.                                     break;
  1367.                                 }
  1368.                             ENDFORSET(fs1); 
  1369.                         }
  1370.                         if (exists && NATURE(arg1_name) == na_obj 
  1371.                             && NATURE(base_type(TYPE_OF(arg1_name))) == na_array)
  1372.                             need_constr_type = TRUE;
  1373.                         if (need_constr_type)
  1374.                             ok_types = set_with(ok_types, (char *) isym);
  1375.                         else
  1376.                             ok_types =
  1377.                               set_with(ok_types, (char *) base_type(isym));
  1378. #endif
  1379.                         ok_types = set_with(ok_types, (char *) base_type(isym));
  1380.                     }
  1381.                 ENDFORSET(fs2);
  1382.             ENDFORSET(fs1);
  1383.  
  1384.             if (set_size( ok_types) ==  1)
  1385.                 t1 = t2 = (Symbol) set_arb(ok_types);
  1386.             else {
  1387.                 univ = set_new(0);
  1388.                 FORSET(t1=(Symbol), ok_types, fs1);
  1389.                     if (in_univ_types(t1))
  1390.                         univ = set_with(univ, (char *) t1);
  1391.                 ENDFORSET(fs1);
  1392.                 if (set_size(univ) == 1)
  1393.                     t1 = t2 = (Symbol) set_arb(univ);
  1394.                 else {
  1395.                     type_error(set_new1((char *)op_name),
  1396.                       (Symbol)0, set_size(ok_types), expn);
  1397.                     return;
  1398.                 }
  1399.             }
  1400.             if (is_limited_type(t1)
  1401.               && (op_name !=symbol_in && op_name!=symbol_notin)) {
  1402.                 errmsg_id("% not available on a limited type", op_name,
  1403.                   "7.4.2", o);
  1404.                 return;
  1405.             }
  1406.             /* Now resolve each operand independently.*/
  1407.  
  1408.             resolve2(arg1, t1);
  1409.             /* The membership tests are not static but their arguments 
  1410.               * may be universal. Convert them to non-universal form for 
  1411.               * run-time evaluation. Also special case type mark as second arg.
  1412.               */
  1413.             if (op_name == symbol_in || op_name == symbol_notin) {
  1414.                 if (t2 == symbol_universal_integer)
  1415.                     specialize(arg1, symbol_integer);
  1416.                 else if (t2 == symbol_universal_real)
  1417.                     specialize(arg1, symbol_float);
  1418.                 if (N_KIND(arg2) != as_simple_name)
  1419.                     resolve2(arg2, t2);
  1420.                 else
  1421.                 /* type mark. Its type is of course its own name. */
  1422.                 N_TYPE(arg2) = N_UNQ(arg2);
  1423.             }
  1424.             else             /* resolve second argument */
  1425.                 resolve2(arg2, t2);
  1426.             /* Comparison operators on  literal expressions are evaluated
  1427.              * separately,  because their arguments are in universal form.
  1428.              */
  1429.             if (in_comparison_ops(op_name ) && t1 == t2
  1430.               && in_univ_types(t1))
  1431.                 literal_expression(expn);
  1432.         }
  1433.         else if (typ == symbol_array_type) { /* Concatenation operator.*/
  1434.             if (op_name == symbol_cat) {
  1435.                 resolve2 (arg1, ctx_type);
  1436.                 resolve2 (arg2, ctx_type);
  1437.             }
  1438.             else {
  1439.                 if (op_name == symbol_cat_ac) {
  1440.                     resolve2 (arg1, ctx_type);
  1441.                     resolve2 (arg2, component_type (ctx_type));
  1442.                     eval_static(arg2);
  1443.                 }
  1444.                 else {
  1445.                     if (op_name == symbol_cat_ca) {
  1446.                         resolve2 (arg1, component_type (ctx_type));
  1447.                         resolve2 (arg2, ctx_type);
  1448.                         eval_static(arg1);
  1449.                     }
  1450.                     else {
  1451.                         if (op_name == symbol_cat_cc) {
  1452.                             resolve2 (arg1, component_type (ctx_type));
  1453.                             eval_static(arg1);
  1454.                             resolve2 (arg2, component_type (ctx_type));
  1455.                             eval_static(arg2);
  1456.                         }
  1457.                     }
  1458.                 }
  1459.             }
  1460.         }
  1461.         else {
  1462.             /* Other binary operators.*/
  1463.             resolve2(arg1, ctx_type);
  1464.             resolve2(arg2, ctx_type);
  1465.         }
  1466.     }
  1467.     else {
  1468.         /*Unary operator. Type of argument is that imposed by context.*/
  1469.         arg1 = (Node)arg_list[1];
  1470.         resolve2(arg1, ctx_type);
  1471.         /* if the argument to unary minus is universal real, the default
  1472.          * operator is floating negation. If the context is fixed, adjust
  1473.          * accordingly.
  1474.          */
  1475.         if (op_name == symbol_subufl && is_fixed_type(ctx_type))
  1476.             N_UNQ(N_AST1(expn)) = symbol_subufx;
  1477.         if (in_univ_types(ctx_type))
  1478.             literal_expression(expn);
  1479.     }
  1480. }
  1481.  
  1482. void specialize(Node u_expr, Symbol ctx_type)  /*;specialize*/
  1483. {
  1484.     /* Convert a universal numeric into a specific one, if the context impo-
  1485.      * ses a non-universal numeric type.
  1486.      */
  1487.  
  1488.     int k;
  1489.     Const    v;
  1490.     Rational    ra;
  1491.  
  1492.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  specialize");
  1493.  
  1494.     /*$$$$ Test should be more general.*/
  1495.     k = N_KIND(u_expr);
  1496.     if (k!=as_ivalue && k!=as_int_literal && k!=as_real_literal) return;
  1497.  
  1498.     if (!in_univ_types(ctx_type )) {
  1499.         v = (Const) N_VAL(u_expr);
  1500.  
  1501.         if (is_universal_integer(v)) {
  1502.             N_VAL(u_expr) =
  1503.               (char *) int_const(int_toi(v->const_value.const_uint));
  1504.             if (arith_overflow)
  1505.                 /* overflow has occurs during conversion to integer */
  1506.                 create_raise(u_expr, symbol_constraint_error); 
  1507.             else      /* From universal to SETL integer*/
  1508.                 N_TYPE(u_expr) = symbol_integer; 
  1509.         }
  1510.         else if (is_universal_real(v)) {
  1511.             if ( !is_fixed_type(root_type(ctx_type))) {
  1512.                 /* N_VAL(u_expr)  =
  1513.                  *   (char *) real_const(rat_tor(v->const_value.const_rat,
  1514.                  *   ADA_REAL_DIGITS));
  1515.                  */
  1516.                 ra  = RATV (v);
  1517.  
  1518.                 /* the conversion from a rational to a real value will be
  1519.                  * correct is the rational value belongs to the real interval
  1520.                  */
  1521.  
  1522.                 if (rat_lss (ra, rat_frr (ADA_MIN_REAL)) || 
  1523.                     rat_gtr (ra, rat_frr (ADA_MAX_REAL))) {
  1524.                     /* overflow occurs during conversion */
  1525.                     /*N_VAL (u_expr) = const_new (CONST_OM); */
  1526.                     create_raise(u_expr, symbol_constraint_error);
  1527.                 }
  1528.                 else {
  1529.                     N_VAL(u_expr) =
  1530.                       (char *) real_const(rat_tor(v->const_value.const_rat,
  1531.                       ADA_REAL_DIGITS));
  1532.                     N_TYPE(u_expr) = symbol_float; 
  1533.                 }
  1534.             }
  1535.             else
  1536.                 /* label universal constant with the specific fixed type */
  1537.                 N_TYPE(u_expr) = ctx_type;
  1538.         }
  1539.         /*$$$ Do something about overflow in conversion.*/
  1540.     }
  1541. }
  1542.  
  1543. static Const check_constant_overflow(Const x)        /*;check_constant_overflow*/
  1544. {
  1545.     if is_const_om (x) 
  1546.         return x;
  1547.     else if (is_const_int (x)) {
  1548.         if ((INTV (x) < ADA_MIN_INTEGER) || (INTV(x) > ADA_MAX_INTEGER))
  1549.             return const_new (CONST_OM);
  1550.         else
  1551.             return x;
  1552.     }
  1553.     /* else if (is_const_uint (x)) {
  1554.      *     if (int_lss(UINTV (x), ADA_MIN_INTEGER_MP) || int_gtr(UINTV(x),
  1555.      *    ADA_MAX_INTEGER_MP))
  1556.      *         return const_new (CONST_OM);
  1557.      *  else return x;
  1558.      * }
  1559.      * else if (is_const_rat (x)) {
  1560.      *     if (rat_gtr (RATV (x), ADA_MAX_FLOAT) )
  1561.      *         return const_new (CONST_OM);
  1562.      *     else return x; 
  1563.      */
  1564.     else if (is_const_fixed (x)) {
  1565.         if ((FIXEDV (x) < ADA_MIN_FIXED) || (FIXEDV(x) > ADA_MAX_FIXED))
  1566.             return const_new (CONST_OM);
  1567.         else
  1568.             return x;
  1569.     }
  1570.     else if (is_const_real (x)) {
  1571.         if ((REALV (x) < ADA_MIN_REAL) || (REALV(x) > ADA_MAX_REAL))
  1572.             return const_new (CONST_OM);
  1573.         else
  1574.             return x;
  1575.     }
  1576.     else 
  1577.         return x;
  1578. }
  1579.  
  1580. /*TBSL: check argument types, esp. in calls, for type_error */
  1581. static void literal_expression(Node expn)              /*;literal_expression*/
  1582. {
  1583.     /* TBSL: need to always return uint case converting input
  1584.      * cases of CONST_INT to long form - review this  ds 11 sep 84
  1585.      */
  1586.     /* Use the arbitrary precision arithmetic package to evaluate an arith-
  1587.      * metic expression whose arguments are literal. This routine is called
  1588.      * in contexts that require a universal value, i.e. constant definitions.
  1589.      * If the constituents are not universal, the expression is returned as
  1590.      * is.
  1591.      * Several attributes deliver a universal value, but are nevertheless
  1592.      * evaluated at run-time. If these attributes are companion operands of
  1593.      * literals, then these literals must be converted to non-universal form,
  1594.      * real or integer depending on the attribute. Note that this conversion is
  1595.      * never to a fixed point type, even for attributes of fixed points.
  1596.      */
  1597.  
  1598.     Node    op_node, args_node, e1, e2;
  1599.     Tuple arg_list;
  1600.     Const op1, op2;
  1601.     int is_int;
  1602.     Symbol    sym;
  1603.     Const    ivalue;
  1604.  
  1605.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  literal_expression");
  1606.  
  1607.     op_node = N_AST1(expn);
  1608.     args_node = N_AST2(expn);
  1609.     arg_list = N_LIST(args_node);
  1610.  
  1611.     if (tup_size( arg_list) == 2 ) {    /* binary operation.*/
  1612.         e1 = (Node) arg_list[1];
  1613.         e2 = (Node) arg_list[2];
  1614.  
  1615.         if (N_KIND(e1) == as_ivalue) {
  1616.             op1 = (Const) N_VAL(e1);
  1617.             /* extract possible values */
  1618.             if (N_KIND(e2) == as_ivalue) {
  1619.                 op2 = (Const) N_VAL(e2);
  1620.                 /* In the case of mixed mode operations on fixed types, the
  1621.                  * second argument is already folded to INTEGER. If a static
  1622.                  * evaluation is possible, make it into a universal object again
  1623.                  */
  1624.                 if (is_const_int(op2)
  1625.                   && (is_const_rat(op1) || N_UNQ(op_node) == symbol_expi))
  1626.                     op2 = uint_const(int_fri(INTV(op2)));
  1627.             }
  1628.             else {
  1629.                 /* op2 is attribute expr. If first operand is integer, check
  1630.                  * its bounds . If it is a mixed operation, convert the first
  1631.                  * operand to the most precise floating type available.
  1632.                  */
  1633.                 if(is_const_int(op1) || is_const_uint(op1))
  1634.                     specialize(e1, symbol_integer);
  1635.                 else
  1636.                     specialize(e1, symbol_float);
  1637.                 return;
  1638.             }
  1639.         }
  1640.         else {            /* op1 is attribute expr.*/
  1641.             if (N_KIND(e2) == as_ivalue) {
  1642.                 op2 = (Const) N_VAL(e2);
  1643.                 if(is_const_int(op2) || is_const_uint(op2))
  1644.                     specialize(e2, symbol_integer);
  1645.                 else
  1646.                     specialize(e2, symbol_float);
  1647.                 return;
  1648.             }
  1649.             else {            /* They both are.*/
  1650.                 return;
  1651.             }
  1652.         }
  1653.     }
  1654.     else {
  1655.         e1 = (Node) arg_list[1];
  1656.         if (N_KIND(e1) != as_ivalue) {
  1657.             return;
  1658.         }
  1659.         else {
  1660.             op1 = (Const) N_VAL(e1);
  1661.         }
  1662.     }
  1663.  
  1664.     is_int = is_universal_integer(op1);
  1665.     if ((! is_int && !(is_const_rat(op1)))
  1666.       || (tup_size(arg_list) == 2 && !(is_const_uint(op2))
  1667.       && !(is_const_rat(op2)))) {
  1668.         return;
  1669.     }
  1670.  
  1671.     sym =N_UNQ(op_node);
  1672.  
  1673.     if (sym == symbol_addi) {
  1674.         const_check(op1, CONST_UINT);
  1675.         const_check(op2, CONST_UINT);
  1676.         ivalue = uint_const(int_add(UINTV(op1), UINTV(op2)));
  1677.     }
  1678.     else if (sym == symbol_addfl || sym == symbol_addfx) {
  1679.         const_check(op1, CONST_RAT);
  1680.         const_check(op2, CONST_RAT);
  1681.         ivalue = rat_const(rat_add(RATV(op1), RATV(op2)));
  1682.     }
  1683.     else if (sym == symbol_subi) {
  1684.        const_check(op1, CONST_UINT);
  1685.        const_check(op2, CONST_UINT);
  1686.        ivalue = uint_const(int_sub(UINTV(op1), UINTV(op2)));
  1687.     }
  1688.     else if (sym == symbol_subfl|| sym == symbol_subfx) {
  1689.         const_check(op1, CONST_RAT);
  1690.         const_check(op2, CONST_RAT);
  1691.         ivalue = rat_const(rat_sub(RATV(op1), RATV(op2)));
  1692.     }
  1693.     else if (sym == symbol_muli) {
  1694.         const_check(op1, CONST_UINT);
  1695.         const_check(op2, CONST_UINT);
  1696.         ivalue = uint_const(int_mul(UINTV(op1), UINTV(op2)));
  1697.     }
  1698.     else if (sym == symbol_mulfl || sym == symbol_mulfx) {
  1699.         const_check(op1, CONST_RAT);
  1700.         const_check(op2, CONST_RAT);
  1701.         ivalue =  rat_const(rat_mul(RATV(op1), RATV(op2)));
  1702.     }
  1703.     else if (sym == symbol_mulfxi || sym == symbol_mulfli) {
  1704.         const_check(op1, CONST_RAT);
  1705.         const_check(op2, CONST_UINT);
  1706.         RATV(op1) = RATV(op1);
  1707.         ivalue = rat_const(rat_red(int_mul(num(RATV(op1)), UINTV(op2)),
  1708.           den(RATV(op1))));
  1709.     }
  1710.     else if (sym == symbol_divfxi || sym == symbol_divfli) {
  1711.         const_check(op1, CONST_RAT);
  1712.         const_check(op2, CONST_UINT);
  1713.         if (int_eql(UINTV(op2),int_fri(0)))
  1714.             ivalue = const_new(CONST_OM);
  1715.         else
  1716.                ivalue = rat_const(rat_red(num(RATV(op1)), int_mul(den(RATV(op1)), 
  1717.               UINTV(op2))));
  1718.     }
  1719.     else if (sym == symbol_divi) {
  1720.         const_check(op1, CONST_UINT);
  1721.         const_check(op2, CONST_UINT);
  1722.         ivalue = uint_const(int_quo(UINTV(op1), UINTV(op2)));
  1723.     }
  1724.     else if (sym == symbol_divfl || sym == symbol_divfx) {
  1725.         const_check(op1, CONST_RAT);
  1726.         const_check(op2, CONST_RAT);
  1727.         ivalue =  rat_const(rat_div(RATV(op1), RATV(op2)));
  1728.     }
  1729.     else if (sym == symbol_remi) {
  1730.         const_check(op2, CONST_UINT);
  1731.         if (int_eql(UINTV(op2),int_fri(0)))
  1732.             ivalue = const_new(CONST_OM);
  1733.         else
  1734.             ivalue = uint_const(int_rem(UINTV(op1), UINTV(op2)));
  1735.     }
  1736.     else if (sym == symbol_modi) {
  1737.         const_check(op2, CONST_UINT);
  1738.         if (int_eql(UINTV(op2),int_fri(0)))
  1739.             ivalue = const_new(CONST_OM);
  1740.         else {
  1741.             const_check(op1, CONST_UINT);
  1742.             const_check(op2, CONST_UINT);
  1743.             ivalue = uint_const(int_mod(UINTV(op1), UINTV(op2)));
  1744.         }
  1745.     }
  1746.     else if (sym == symbol_expi) {
  1747.         const_check(op2, CONST_UINT);
  1748.         if (int_lss(UINTV(op2),int_fri(0)))
  1749.             ivalue = const_new(CONST_OM); 
  1750.         else {
  1751.             const_check(op1, CONST_UINT);
  1752.             const_check(op2, CONST_UINT);
  1753.             ivalue = uint_const(int_exp(UINTV(op1), UINTV(op2)));
  1754.         }
  1755.     }
  1756.     else if (sym == symbol_expfl) {
  1757.         const_check(op1, CONST_RAT);
  1758.         const_check(op2, CONST_UINT);
  1759.         ivalue = rat_const(rat_exp(RATV(op1), UINTV(op2)));
  1760.     }
  1761.     else if (sym == symbol_eq) {
  1762.         ivalue = int_const(const_eq(op1, op2));
  1763.     }
  1764.     else if (sym == symbol_ne) {
  1765.         ivalue = int_const(!const_eq(op1, op2));
  1766.     }
  1767.     else if(sym == symbol_gt) {
  1768.         ivalue = int_const(const_gt(op1, op2));
  1769.     }
  1770.     else if (sym == symbol_lt) {
  1771.         ivalue = int_const(const_lt(op1, op2));
  1772.     }
  1773.     else if (sym == symbol_ge) {
  1774.         ivalue= int_const(const_ge(op1, op2));
  1775.     }
  1776.     else if (sym == symbol_le)  {
  1777.         ivalue = int_const(const_le(op1, op2));
  1778.     }
  1779.     else if (sym == symbol_addui || sym == symbol_addufl || sym==symbol_addufx){
  1780.         ivalue = op1;
  1781.     }
  1782.     else if(sym == symbol_subui) {
  1783.         const_check(op1, CONST_UINT);
  1784.         ivalue = uint_const(int_umin(UINTV(op1)));
  1785.     }
  1786.     else if (sym == symbol_subufl || sym == symbol_subufx) {
  1787.         const_check(op1, CONST_RAT);
  1788.         ivalue = rat_const(rat_umin(RATV(op1)));
  1789.     }
  1790.     else if (sym == symbol_absi) {
  1791.         const_check(op1, CONST_UINT);
  1792.         ivalue = uint_const(int_abs(UINTV(op1)));
  1793.     }
  1794.     else if (sym == symbol_absfl || sym == symbol_absfx) {
  1795.         const_check(op1, CONST_RAT);
  1796.         ivalue = rat_const(rat_abs(RATV(op1)));
  1797.     }
  1798.     else {         /* Error: not a universal operator. */
  1799.         ivalue = const_new(CONST_OM); 
  1800.     }
  1801.  
  1802.     /* the previous calculus may have raised the overflow flag 
  1803.      * if (arith_overflow) {
  1804.      *     arith_overflow = FALSE;
  1805.      *     ivalue =  const_new (CONST_OM);}
  1806.      */
  1807.  
  1808.     ivalue = check_constant_overflow (ivalue);
  1809.  
  1810.     if (ivalue->const_kind == CONST_OM)
  1811.         create_raise(expn, symbol_constraint_error);
  1812.     else {
  1813.         N_KIND(expn) = as_ivalue;
  1814.         N_AST1(expn) = N_AST2(expn) = N_AST3(expn) = N_AST4(expn) = (Node)0;
  1815.         copy_span(e1, expn);
  1816.         N_VAL(expn) = (char *)ivalue;
  1817.     }
  1818. }
  1819.  
  1820. static Tuple order_arg_list(Node arg_list_node, Tuple sig) /*;order_arg_list*/
  1821. {
  1822.     /* Normalize an argument list (possibly containing named associations)
  1823.      * according to the signature -sig-. Called for subprogram and operators.
  1824.      */
  1825.  
  1826.     Tuple    arg_list;
  1827.     Node    actual, arg, choice_list, a_expr, choice_node, id_node;
  1828.     int        p, actuals_seen, i, first_named;
  1829.     Tuple    new_list;
  1830.     Tuple    named_args;
  1831.     Symbol    f_name;
  1832.     int found_name;
  1833.     int        exists;
  1834.     Fortup    ft1, ft2;
  1835.  
  1836.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : order_arg_list");
  1837.  
  1838.     arg_list = N_LIST(arg_list_node);
  1839.     exists = FALSE;
  1840.     FORTUPI(actual=(Node), arg_list, p, ft1);
  1841.         if (N_KIND(actual) == as_choice_list) {
  1842.             exists = TRUE;
  1843.             break;
  1844.         }
  1845.     ENDFORTUP(ft1);
  1846.     if (exists) {
  1847.         first_named = p;
  1848.         exists = FALSE;
  1849.         for (i = p+1;i <= tup_size(arg_list); i++) {
  1850.             actual = (Node) arg_list[i];
  1851.             if (N_KIND(actual) != as_choice_list) {
  1852.                 exists= TRUE;
  1853.                 break;
  1854.             }
  1855.         }
  1856.         if (exists) {
  1857.             errmsg("No positional arguments can appear after named ones",
  1858.               "6.4", actual);
  1859.             return (Tuple)0;
  1860.         }
  1861.     }
  1862.     else
  1863.         first_named = tup_size(arg_list) + 1;
  1864.     new_list = tup_new(first_named - 1);
  1865.     for (i = 1; i < first_named; i++)
  1866.         new_list[i] = arg_list[i];
  1867.     named_args = tup_new(tup_size(arg_list) - first_named + 1);
  1868.     for (i = first_named; i <= tup_size(arg_list); i++)
  1869.         named_args[i - first_named + 1] = arg_list[i];
  1870.     actuals_seen = first_named - 1;
  1871.  
  1872.     FORTUP(arg=(Node), named_args, ft1);
  1873.         choice_list = N_AST1(arg);
  1874.         a_expr = N_AST2(arg);
  1875.         exists = FALSE;
  1876.         if (tup_size(N_LIST(choice_list)) != 1) exists = TRUE;
  1877.         if (exists == FALSE) {
  1878.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1879.                 if (N_KIND(choice_node) != as_choice_unresolved) {
  1880.                     exists = TRUE;
  1881.                     break;
  1882.                 }
  1883.             ENDFORTUP(ft2);
  1884.         }
  1885.         if ( exists ) {
  1886.             errmsg("Invalid format for argument association", "6.4",
  1887.               choice_list);
  1888.             return (Tuple)0;
  1889.         }
  1890.     ENDFORTUP(ft1);
  1891.  
  1892.     if (cdebug2 > 2) {
  1893.     }
  1894.  
  1895.     for (i = first_named; i <= tup_size(sig); i++) {
  1896.         f_name = (Symbol) sig[i];
  1897.         found_name = FALSE;
  1898.  
  1899.         FORTUP(arg=(Node), named_args, ft1);
  1900.             choice_list = N_AST1(arg);
  1901.             a_expr = N_AST2(arg);
  1902.             id_node = N_AST1((Node) (N_LIST(choice_list)[1]));
  1903.             if (streq(N_VAL(id_node), original_name(f_name))) {
  1904.                 found_name = TRUE;
  1905.                 break;
  1906.             }
  1907.         ENDFORTUP(ft1);
  1908.  
  1909.         if (found_name) {
  1910.             new_list = tup_with(new_list, (char *) a_expr);
  1911.             actuals_seen += 1;
  1912.             current_node = id_node;
  1913.             check_void(N_VAL(id_node));
  1914.         }
  1915.         else if ((Node) default_expr(f_name) != OPT_NODE)
  1916.             new_list = tup_with(new_list , (char *) OPT_NODE);
  1917.             /* Just a marker. Type is correct*/
  1918.         else            /* Name not present*/
  1919.             return (Tuple)0;
  1920.     }
  1921.  
  1922.     if (cdebug2 > 2) {
  1923.     }
  1924.  
  1925.     if (actuals_seen == tup_size(arg_list)        /* all actuals seen.*/
  1926.       && tup_size(new_list) == tup_size(sig))  /* all formals matched */
  1927.         return(new_list);
  1928.     else return (Tuple)0;
  1929. }
  1930.  
  1931. void complete_arg_list(Tuple formals, Node arg_list_node) /*;complete_arg_list*/
  1932. {
  1933.     /* This procedure completes the formatting of the argument list of
  1934.      * a subprogram or entry call. This is done in the second,
  1935.      * top-down pass of overloading resolution. The argument list is
  1936.      * reordered, the names of the formals are removed from the actuals,
  1937.      * and default values are inserted in the place of missing parameters.
  1938.      * Types have already been validated during pass one, and default para-
  1939.      * meters are known to exist where needed.
  1940.      */
  1941.  
  1942.     Tuple    arg_list, complete_args;
  1943.     int        i;
  1944.     Node    actual, default_node, default_copy;
  1945.     Fortup    ft1;
  1946.     Symbol    f;
  1947.  
  1948.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_arg_list");
  1949.  
  1950.     arg_list = order_arg_list(arg_list_node, formals); /* Normalize arguments*/
  1951.     /* if arg_list = om then ?*/
  1952.  
  1953.     complete_args = tup_new(0);
  1954.     /* Complete type resolution of each actual, and insert default expression
  1955.      * for those that are missing; default expressions are known to exist.
  1956.      */
  1957.     FORTUPI(f=(Symbol), formals, i, ft1);
  1958.         actual = (Node) arg_list[i];
  1959.         /* If no named association, a default value must be present,
  1960.          * unless, there was a previous error.
  1961.          */
  1962.  
  1963.         if (actual == OPT_NODE) {
  1964.             if (f != symbol_any_id) {
  1965.                 default_node = (Node) default_expr(f);
  1966.                 /* we assume all trees read in before use so node should be
  1967.                  * available.
  1968.                  */
  1969.                 default_copy = copy_tree(default_node);
  1970.                 if (fold_context) eval_static(default_copy);
  1971.                 /* No constant folding in the middle of a conformance check */
  1972.                 complete_args = tup_with(complete_args, (char *) default_copy);
  1973.             }
  1974.             else        /* previous error. */
  1975.                 complete_args = tup_with(complete_args, (char *) OPT_NODE);
  1976.         }
  1977.         else {
  1978.             bind_arg(actual, TYPE_OF(f), NATURE(f), i);
  1979.             if (fold_context) eval_static(actual);
  1980.             complete_args = tup_with(complete_args, (char *) actual);
  1981.         }
  1982.     ENDFORTUP(ft1);
  1983.     N_LIST(arg_list_node) = complete_args;
  1984. }
  1985.  
  1986. static void bind_arg(Node actual, Symbol f_type, int f_mode, int i)/*;bind_arg*/
  1987. {
  1988.     /* Unlike the high-level version of Ada/Ed, the C front-end does not
  1989.      * indicate what constraints, if any, must be applied to actual parameters.
  1990.      * The job is done completely by the code generator, and sequences of
  1991.      * constraint checks on entry and exit are emitted in gen_prelude and
  1992.      * gen_postlude.
  1993.      */
  1994.  
  1995.     Set a_types;
  1996.     Symbol    a_type;
  1997.     int out_c;
  1998.     Node    a;
  1999.     int        exists, may_others;
  2000.     Forset    fs1;
  2001.  
  2002.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  bind_arg");
  2003.  
  2004.     a_types = N_PTYPES(actual);
  2005.  
  2006.     /* One of its possible types must be compatible with the formal.*/
  2007.     exists = FALSE;
  2008.     FORSET(a_type=(Symbol), a_types, fs1);
  2009.         if(compatible_types(f_type, a_type)) {
  2010.             exists = TRUE;
  2011.             break;
  2012.         }
  2013.     ENDFORSET(fs1);
  2014.     if (!exists) /* assertion failure */
  2015.         chaos("assertion failure bind_arg");
  2016.     /* An out parameter may appear as the actual for another out parameter.*/
  2017.     out_c = out_context;
  2018.     out_context = (f_mode == na_out);
  2019.     /*  If the actual is an aggregate, there is no sliding for it, and named
  2020.      *  associations can appear with "others" (cf. 4.3.2(6)).
  2021.      */
  2022.     may_others = full_others;
  2023.     full_others = TRUE;
  2024.  
  2025.     resolve2(actual, f_type);
  2026.     apply_constraint (actual, f_type);
  2027.  
  2028.     /* verify that inout and out parameters are valid targets
  2029.      * of assignments.
  2030.      */
  2031.     if (N_KIND(actual) == as_qual_range || N_KIND(actual) == as_qual_index
  2032.       || N_KIND(actual) == as_qual_discr || N_KIND(actual) == as_qual_aindex 
  2033.       || N_KIND(actual) == as_qual_adiscr)
  2034.         a = N_AST1(actual);
  2035.     else
  2036.         a = actual;
  2037.  
  2038.     if (N_KIND(a) == as_insert)   /* case of an array conversion */
  2039.         a = N_AST1(a);
  2040.     if (f_mode != na_in && 
  2041.         /*
  2042.          * check for conversion explicitly here, as is_variable() no
  2043.          * longer allows conversions.
  2044.          */
  2045.         !(is_variable(a) || N_KIND(a)==as_convert && is_variable(N_AST2(a)))) {
  2046.         errmsg_str_num("% actual parameter no. % in call is not a variable",
  2047.           nature_str(f_mode), i, "6.4.1", actual);
  2048.     }
  2049.  
  2050.     if (is_scalar_type(f_type)) /* Convert from universal value if need be.*/
  2051.         specialize(actual, f_type);
  2052.     out_context = out_c;
  2053.     full_others = may_others;
  2054. }
  2055.  
  2056. static int in_comparison_ops(Symbol op)            /*;in_comparison_ops*/
  2057. {
  2058.     /* test for comparison operator */
  2059.     return (
  2060.       op == symbol_eq || op == symbol_ne
  2061.       || op == symbol_lt || op == symbol_gt
  2062.       || op == symbol_le || op == symbol_ge );
  2063. }
  2064.  
  2065. static Set find_compatible_type(Set typ1, Set typ2) /*; find_compatible_type */
  2066. {
  2067.     /* return the types of typ1 (t1) such as the component type of t1 is 
  2068.      * compatible with at least one type of typ2
  2069.     */
  2070.  
  2071.     Set result;
  2072.     Symbol t1, t2;
  2073.     Forset fs1, fs2;
  2074.  
  2075.     result = set_new (0);
  2076.  
  2077.     FORSET (t1 = (Symbol), typ1, fs1);
  2078.         FORSET (t2 = (Symbol), typ2, fs2);
  2079.         if (compatible_types ((Symbol) component_type (t1), t2))
  2080.             result = set_with (result, (char *) base_type (t1)); 
  2081.         ENDFORSET (fs2);
  2082.     ENDFORSET (fs1);
  2083.     return result;
  2084. }
  2085.  
  2086. static Tuple valid_concatenation_type(Set typ1, Set typ2)
  2087.                                                 /*;valid_concatenation_type*/
  2088. {
  2089.     /* Concatenation is performed by 4 distinct operators, corresponding to
  2090.      * array-array, array-component, component-array, and component-component
  2091.      * cases. If either operand is an aggregate, or if both operands are
  2092.      * components, then the candidate resulting types are a subset of the
  2093.      * one-dimensional array types that are in scope.
  2094.      */
  2095.  
  2096.     Set arrays1, arrays2, arrays3, types, new_types;
  2097.     Set opns, types1, types2, types3;
  2098.     Symbol t1, t2, t3;
  2099.     Forset fs1, fs2, fs3;
  2100.     Tuple tup;
  2101.     int exist_composite_in_typ1, exist_composite_in_typ2;
  2102.  
  2103.     arrays1 = set_new (0);
  2104.     arrays2 = set_new (0);
  2105.     arrays3 = set_new (0);
  2106.     types = set_new (0);
  2107.     opns = set_new (0);
  2108.  
  2109.     FORSET  (t1=(Symbol), typ1, fs1);
  2110.         if (is_array (t1) && no_dimensions (t1) == 1)
  2111.             arrays1 = set_with (arrays1, (char *) base_type (t1));
  2112.     ENDFORSET (fs1);
  2113.  
  2114.     FORSET  (t1=(Symbol), typ2, fs1);
  2115.         if (is_array (t1) && no_dimensions (t1) == 1)
  2116.             arrays2 = set_with (arrays2, (char *) base_type (t1));
  2117.     ENDFORSET (fs1);
  2118.  
  2119.     FORSET  (t1=(Symbol), find_agg_types (), fs1);
  2120.         if (is_array (t1) && no_dimensions (t1) == 1)
  2121.             arrays3 = set_with (arrays3, (char *) base_type (t1));
  2122.     ENDFORSET (fs1);
  2123.  
  2124.     exist_composite_in_typ1 = FALSE;
  2125.     FORSET (t1 = (Symbol), typ1, fs1);
  2126.         if (NATURE (base_type (t1)) == na_aggregate)
  2127.         { 
  2128.             exist_composite_in_typ1 = TRUE; 
  2129.             break; 
  2130.         }
  2131.     ENDFORSET (fs1);
  2132.  
  2133.     exist_composite_in_typ2 = FALSE;
  2134.     FORSET (t1 = (Symbol), typ2, fs1);
  2135.         if (NATURE (base_type (t1)) == na_aggregate)
  2136.         { 
  2137.             exist_composite_in_typ2 = TRUE; 
  2138.             break; 
  2139.         }
  2140.     ENDFORSET (fs1);
  2141.  
  2142.     /* First we look for compatible arrays to concatenate. */
  2143.     if (exist_composite_in_typ1)
  2144.         types = arrays2; 
  2145.     else
  2146.     {
  2147.         FORSET (t1 = (Symbol), arrays1, fs1);
  2148.             FORSET (t2 = (Symbol), typ2, fs2);
  2149.                 if (compatible_types (t1, t2))
  2150.                     types = set_with (types, (char *) base_type (t1));
  2151.             ENDFORSET (fs2);
  2152.         ENDFORSET (fs1);
  2153.     }
  2154.     if (set_size (types) != 0)
  2155.         opns = set_with (opns, (char *)symbol_cat); 
  2156.  
  2157.     /* Next, look for aggregate or array type concatenated with compatible
  2158.      * component.
  2159.      */
  2160.     if (exist_composite_in_typ1)
  2161.         types1 = find_compatible_type (arrays3, typ2);
  2162.     else
  2163.         types1 = find_compatible_type (arrays1, typ2);
  2164.  
  2165.     if (set_size (types1) != 0)
  2166.     { 
  2167.         types = set_union (types, types1);
  2168.         opns = set_with (opns, (char *)symbol_cat_ac);
  2169.     }
  2170.  
  2171.     /* The component-array case is similar. */
  2172.     if (exist_composite_in_typ2)
  2173.         types2 = find_compatible_type (arrays3, typ1);
  2174.     else
  2175.         types2 = find_compatible_type (arrays2, typ1);
  2176.     if (set_size (types2) != 0)
  2177.     { 
  2178.         types = set_union (types, types2);
  2179.         opns = set_with (opns, (char *)symbol_cat_ca);
  2180.     }
  2181.  
  2182.     /* Next, both arguments may be the component type of some one-dimensional 
  2183.      * array type, as in `A` & 'B'. Note that the arguments may still be
  2184.      * arrays, and the result type be a one-dimensional array of arrays.
  2185.      * The candidate resulting types are all array types in scope whose
  2186.      * component types are compatible with both operands.
  2187.      */
  2188.  
  2189.     types3 = set_new (0);
  2190.     FORSET (t1 = (Symbol), arrays3, fs1);
  2191.         FORSET (t2 = (Symbol), typ1, fs2);
  2192.             FORSET (t3 = (Symbol), typ2, fs3);
  2193.             if (compatible_types ((Symbol) component_type (t1), t2)
  2194.               && compatible_types ((Symbol) component_type (t1), t3))
  2195.                 types3 = set_with (types3, (char *)base_type (t1)); 
  2196.             ENDFORSET (fs3);
  2197.         ENDFORSET (fs2);
  2198.     ENDFORSET (fs1);
  2199.  
  2200.     if (set_size (types3) != 0) { 
  2201.         types = set_union (types, types3);
  2202.         opns = set_with (opns, (char *)symbol_cat_cc);
  2203.     }
  2204.  
  2205.     /* Finally, if both arguments are aggregates, the result can be an array
  2206.      * type.
  2207.      */
  2208.     if ((exist_composite_in_typ1)  && (exist_composite_in_typ2)) {
  2209.         types = set_with (types, (char *)symbol_array_type);
  2210.         opns = set_with (opns, (char *)symbol_cat);
  2211.     }
  2212.  
  2213.     new_types = set_new (0);
  2214.     FORSET (t1 = (Symbol), types, fs1);
  2215.         if (! is_limited_type (t1))
  2216.             new_types = set_with (new_types , (char *) t1);
  2217.     ENDFORSET (fs1);
  2218.  
  2219.     tup = tup_new (2);
  2220.     tup [1] = (char *) opns;
  2221.     tup [2] = (char *) new_types;
  2222.  
  2223.     return tup;
  2224. }
  2225.